Cream of the Crop 1/Cream of the Crop 1.iso/PROGRAM/TAN_SND.ARJ/DRUMS.PAS

Pascal/Delphi Source File | 1991-07-28 | 6KB | 306 lines

unit drums;   { DRUMS.PAS  Copyright (c) 1990 DSoft Specialties }
interfac      { Drum routines for the Tandy 1000 and/or PCJr. See DRUMS.SIM }
uses dos,noiz;

{ All I ask is if you use any of these routines in your program
  please mention DSoft in the docs or in a copyright message }

type
  echo_style = (short,long);

const
  drumpitch: word = 0;
  inturbo: boolean = true;

procedure wait(dt: longint);
procedure delay(dt: longint);
procedure drum_pitch(i: word);
procedure down(snd,step: byte;pitch: word);
procedure up(snd,step: byte;pitch: word);
procedure noise(ch: char;sr,amp,duration: word);
procedure dwn(reps,tone,dur: integer);
procedure snare(reps,dur: byte);
procedure tom(reps,dur: byte);
procedure lowtom(reps,dur: byte);
procedure bass(reps,dur: byte);
procedure bass2(reps,dur: byte);
procedure roto1(reps,dur: byte);
procedure roto2(reps,dur: byte);
procedure roto5(reps,tone,dur: integer);
procedure sims(reps,dur: byte);
procedure sims1(reps,dur: byte);
procedure sims2(reps,dur: byte);
procedure sims3(reps,dur: byte);
procedure crash(reps,dur: integer);
procedure roll(reps,dur,crashdur: integer);
procedure lick(reps: byte);
procedure echo(del: word;es: echo_style);
procedure quiet;
function fkey: char;
function keyhit: boolean;

implementation

procedure wait(dt: longint);
const
  inturb = 30;
  indos = 42;
var tt,ir,tr: longint;
begin
  if inturbo then
    tt:=inturb
  else
    tt:=indos;
  for ir:=1 to dt do
    for tr:=1 to tt do
end;

procedure delay(dt: longint);
begin
  wait(dt);
end;

procedure drum_pitch(i: word);
var j: integer;
begin
  for j:=0 to 3 do sound_pitch(j,i);
end;

procedure down(snd,step: byte;pitch: word);
var i: byte;
begin
  port[$C0]:=$E0+1*4+snd;
  for i:=0 to 15 do
  begin
    port[$C0]:=$F0+i;
    wait(step);
  end;
  drum_pitch(pitch);
end;

procedure up(snd,step: byte;pitch: word);
var i: byte;
begin
  port[$C0]:=$E0+1*4+snd;
  for i:=15 downto 0 do
  begin
    port[$C0]:=$F0+i;
    wait(step);
  end;
  port[$C0]:=$FF;
  drum_pitch(pitch);
end;

procedure noise(ch: char;sr,amp,duration: word);
var portpass1: integer;
begin
  portpass1:=224;
  if (ch in ['W','w']) then portpass1:=portpass1 + 4;
  case sr of
    10: portpass1:=portpass1 + 1;
    20: portpass1:=portpass1 + 2;
  end;
  port[$C0]:=240+amp;
  port[$C0]:=portpass1;
  wait(duration);
end;

procedure dwn(reps,tone,dur: integer);
var i,j,k: integer;
begin
  for i:=1 to reps do
  begin
    for j:=0 to 15 do
    begin
      noise('w',tone,j,dur); noise(' ',0,15,1);
    end;
  end;
end;

procedure snare(reps,dur: byte);
var i: byte;
begin
  for i:=1 to reps do down(0,dur,drumpitch);
end;

procedure tom(reps,dur: byte);
var i: byte;
begin
  drumpitch:=0;
  for i:=1 to reps do down(1,dur,drumpitch);
end;

procedure lowtom(reps,dur: byte);
var i: byte;
begin
  for i:=1 to reps do down(2,dur,drumpitch);
end;

procedure bass(reps,dur: byte);
var i: byte;
begin
  for i:=1 to reps do down(3,dur,0);
end;

procedure bass2(reps,dur: byte);
var i: byte;
begin
  for i:=1 to reps do
  begin
    down(3,dur div 2,drumpitch);
    down(2,dur div 2,drumpitch);
  end;
end;

procedure roto1(reps,dur: byte);
var i,j: integer;
begin
  for i:=1 to reps do
  begin
    up(1,dur,20); down(2,dur,0);
  end;
end;

procedure roto2(reps,dur: byte);
var i,j: integer;
begin
  for i:=1 to reps do
  begin
    up(2,1,0);
    for j:=140 to 340 do sound(j);
    wait(dur); nosound;
  end;
  drumpitch:=0;
end;

procedure roto5(reps,tone,dur: integer);
var i,j: integer;
begin
  for i:=1 to reps do
  begin
    dwn(1,tone,dur);
  end;
end;

procedure sims(reps,dur: byte);
var i,j: byte;
begin
  for i:=1 to reps do
  begin
    up(1,1,0);
    for j:=220 downto 23 do sound(j);
    nosound;
    wait(dur);
  end;
end;

procedure sims1(reps,dur: byte);
var i,j: integer;
begin
  for i:=1 to reps do
  begin
    up(1,1,0);
    for j:=440 downto 230 do sound(j);
    nosound;
    wait(dur);
  end;
end;

procedure sims2(reps,dur: byte);
var i,j: integer;
begin
  for i:=1 to reps do
  begin
    up(1,1,0);
    for j:=880 downto 660 do sound(j);
    nosound;
    wait(dur);
  end;
end;

procedure sims3(reps,dur: byte);
var i,j: integer;
begin
  for i:=1 to reps do
  begin
    up(1,1,0);
    for j:=1020 downto 880 do sound(j);
    nosound;
    wait(dur);
  end;
end;

procedure crash(reps,dur: integer);
var i: byte;
begin
  for i:=1 to reps do
  begin
    up(0,4,0);
    down(0,dur,0);
  end;
end;

procedure roll(reps,dur,crashdur: integer);
var i,j: integer;
begin
  for j:=1 to reps do
  begin
    snare(4,dur);
    tom(4,dur);
    lowtom(4,dur);
    bass(4,dur);
  end;
  if (crashdur > 0) then
  begin
    up(0,1,0); down(0,crashdur,0);
  end;
end;

procedure lick(reps: byte);
begin
  up(1,3,drumpitch); up(0,3,drumpitch); up(2,3,drumpitch);
  lowtom(4,2); tom(4,2);
  sims(4,15); up(2,3,drumpitch);
  roll(reps,2,22);
end;

procedure quiet;
begin
  noiz.quiet;
end;

procedure echo(del: word;es: echo_style);
var i: integer;
begin
  for i:=0 to 15 do
  begin
    noiz.noise('w',20,i,del); noiz.noise('w',10,i,2);
    noiz.noise('w',0,i,2);
    case es of
      short: noiz.noise(' ',5,15,0);
       long: noiz.noise(' ',5,15,del);
    end;
  end;
end;

function fkey: char;
var regs: registers;
begin
  regs.AH:=0;
  intr($16,regs);
  if regs.AL=0 then
    fkey:=chr(regs.AH+128)
  else
    fkey:=chr(regs.AL)
end;

function keyhit: boolean;
var regs: registers;
begin
  regs.AH:=1;
  intr($16,regs);
  keyhit:=(regs.flags and 64)=0;
end;

end.